home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / sbprolog / v3 / modlib_s.lha / modlib_src / $dbcmpl.P < prev    next >
Text File  |  1990-04-12  |  19KB  |  567 lines
  1. /* modified with labels 32/33 in buff_code */
  2. /************************************************************************
  3. *                                    *
  4. * The SB-Prolog System                            *
  5. * Copyright SUNY at Stony Brook, 1986; University of Arizona, 1987    *
  6. *                                    *
  7. ************************************************************************/
  8.  
  9. /*-----------------------------------------------------------------
  10. SB-Prolog is distributed in the hope that it will be useful,
  11. but WITHOUT ANY WARRANTY.  No author or distributor
  12. accepts responsibility to anyone for the consequences of using it
  13. or for whether it serves any particular purpose or works at all,
  14. unless he says so in writing.  Refer to the SB-Prolog General Public
  15. License for full details.
  16.  
  17. Everyone is granted permission to copy, modify and redistribute
  18. SB-Prolog, but only under the conditions described in the
  19. SB-Prolog General Public License.   A copy of this license is
  20. supposed to have been given to you along with SB-Prolog so you
  21. can know your rights and responsibilities.  It should be in a
  22. file named COPYING.  Among other things, the copyright notice
  23. and this notice must be preserved on all copies. 
  24. ------------------------------------------------------------------ */
  25. /* $dbcmpl.P */
  26.  
  27. /* This file contains Prolog predicates that compiles a clause into a 
  28. buffer. It treats all rules as though they had a single literal on the
  29. right-hand-side. Thus it compiles a clause with more than one literal
  30. on the right-hand-side as a call to the predicate ,/2 */
  31.  
  32. $dbcmpl_export([$db_cmpl/5,$db_putbuffop/4,$db_putbuffbyte/4,
  33.     $db_putbuffnum/4]).
  34.  
  35. /* 
  36. $dbcmpl_use($buff,[$alloc_perm/2,$alloc_heap/2,$trimbuff/3,$buff_code/4,
  37.                    $symtype/2,$substring/6,$subnumber/6,$subdelim/6,
  38.                    $conlength/2,$pred_undefined/1, $hashval/3]).
  39. $dbcmpl_use($bmeta,[$atom/1,$atomic/1,$integer/1,$number/1,$structure/1,
  40.                     $functor0/2,$bldstr/3,$arg/3,$arity/2,$real/1,$floor/2]).
  41. $db_use($bio,[$writename/1,$writeqname/1,$put/1,$nl/0,$tab/1,$tell/1,$tell/2,
  42.               $telling/1,$told/0,$get/1,$get0/1,$see/1,$seeing/1,$seen/0]).
  43. */
  44.  
  45. $db_putbuffop(Opn,Buff,Li,Lo) :- 
  46.     $buff_code(Buff, Li, 3 /*ps*/ ,Opn), Lo is Li+2.
  47.  
  48. $db_putbuffope(Opn,Buff,Li,Lo) :- 
  49.     $buff_code(Buff, Li,  3 /*ps*/ ,Opn), Li1 is Li+2,
  50.     $buff_code(Buff, Li1, 3 /*ps*/ ,0),   Lo  is Li1+2.
  51.  
  52. $db_putbuffbyte(Num,Buff,Li,Lo) :- 
  53.     $buff_code(Buff, Li, 3 /*ps*/ ,Num), Lo is Li+2.
  54.  
  55. $db_putbuffnum(Num,Buff,Li,Lo) :- 
  56.     $buff_code(Buff, Li, 32 /*pn*/ ,Num), Lo is Li+4.
  57.  
  58. $db_putbuffloat(Num,Buff,Li,Lo) :- 
  59.     $buff_code(Buff, Li, 27 /*pf*/ ,Num), Lo is Li+4.
  60.  
  61. $db_putbuffptr(Num,Buff,Li,Lo) :- 
  62.     $buff_code(Buff, Li, 1 /*pppsc*/ ,Num), Lo is Li+4.
  63.  
  64. $db_putbuffpsc(Num,Buff,Li,Lo) :- 
  65.     $buff_code(Buff, Li, 0 /*ppsc*/ ,Num), Lo is Li+4.
  66.  
  67.  
  68. /* $db_cmpl(Clause,Clref,Index,Where,Supbuff): where Clause is a fact or
  69. rule. Clref is a variable through which is returned the Clref, and 
  70. Index is the argument to index on (0 if none). Where is 0 if the 
  71. buffer is to be allocated from the permanent area, and 2 if from a
  72. superbuff, which is in Supbuff. */
  73.  
  74. $db_cmpl(Clause,Buff,Index,Where,Supbuff) :- 
  75.     $alloc_buff(10000,Buff,Where,Supbuff,_),    /* must return Buff */
  76.     ((Clause ?= (_:-_) -> Clause=(Head:-Body); Clause=Head, Body=true),
  77.      $arity(Head,Arity),
  78.      Tempreg is Arity+1, 
  79.      $buff_code(Buff, 0, 14 /*ptv*/ ,Buff), /*set back pointer*/
  80.          $opcode( noop, NoOp ),
  81.      $db_putbuffop(NoOp, Buff, 12, _),
  82.      $buff_code(Buff, 14, 3, 2),  /* skip next 2*2 = 4 bytes */
  83.      $db_putbuffpsc(Head, Buff, 16, _),
  84.      $db_gentop(Head,Arity,1,Tempreg,Freereg,Buff,20,Lhd,uniq),
  85.      $db_flatten(Body,FBody,[],Unifs),
  86.      $db_flcode(Unifs,Freereg,R0,Buff,Lhd,Lm0,uniq),
  87.      $arity(FBody,Barity),
  88.      $db_genbod(FBody,Barity,1,[],Mvl,R0,Maxreg,Buff,Lm0,Lm1,uniq),
  89.      (Index > 0 -> $db_putbuffchain(Buff, Lm1, Length);
  90.                 Length = Lm1),
  91.      (Length > 10000,!,
  92.              $db_mfail('Asserted clause too long ',Length);
  93.       Length =< 10000,
  94.        (Maxreg > 255,!,
  95.          $db_mfail('Assert: too many registers required ',Maxreg);
  96.         Maxreg =< 255,
  97.          $trimbuff(Length,Buff,Where,Supbuff), fail
  98.        )
  99.      )
  100.     ;
  101.      true
  102.     ).
  103.  
  104.  
  105. $db_mfail(Msg,Val) :- 
  106.     $telling(F),$tell(user),
  107.     $writename(Msg),$writename(Val),$nl,
  108.     $tell(F),fail.
  109.  
  110. $db_putbuffchain(Buff, Lin, Lout) :-
  111.         /* put code at the end for chaining clauses in the same bucket  */
  112.         $opcode( noop, NoopOp ),
  113.         $opcode( jump, JmpOp ),
  114.     $db_putbuffop(   NoopOp /* noop */, Buff, Lin, L1),
  115.         $db_putbuffbyte(  2, Buff, L1, L2),   /* 2 noop's */
  116.         $db_putbuffnum(   0, Buff, L2, L3),
  117.         $db_putbuffope(  JmpOp /* jump */, Buff, L3, L4),
  118.         $buff_code(Buff, 12, 33, EPADDR), /* get start address of the code*/
  119.         $db_putbuffnum(EPADDR, Buff, L4, Lout).
  120.  
  121. $db_gentop(Fact,Arity,Argno,Ri,Ro,Buff,Li,Lo,U) :- 
  122.     Argno > Arity,
  123.      Ri = Ro, Li=Lo
  124.     ;
  125.     Argno =< Arity, arg(Argno,Fact,T),
  126.      $db_gentopinst(T,Argno,Ri,Rm,Buff,Li,Lm,U),
  127.      Argno1 is Argno + 1,
  128.      $db_gentop(Fact,Arity,Argno1,Rm,Ro,Buff,Lm,Lo,U).
  129.  
  130. $db_gentopinst(T,Argno,Ri,Ro,Buff,Li,Lo,U) :-
  131.     var(T), T='$var'(Argno,U), Ri = Ro, Li = Lo 
  132.     ;
  133.     nonvar(T),
  134.      ($atom(T) ->
  135.        ((T ?= [] ->
  136.          ($opcode( getnil, GetNilOp ),
  137.                   $db_putbuffop(GetNilOp,Buff,Li,Li1),  /* getnil(Argno) */
  138.           $db_putbuffbyte(Argno,Buff,Li1,Lo)
  139.            ) ;
  140.          ($opcode( getcon, GetConOp ),
  141.                   $db_putbuffop(GetConOp,Buff,Li,Li1),   /* getcon(T,Argno) */
  142.              $db_putbuffbyte(Argno,Buff,Li1,Li2),
  143.              $db_putbuffptr(T,Buff,Li2,Lo)
  144.            )
  145.         ),
  146.         Ri = Ro
  147.        ) ;
  148.        (integer(T) ->             /* getnumcon(T,Argno) */
  149.         ($opcode( getnumcon, GetNumOp ),
  150.                  $db_putbuffop(GetNumOp,Buff,Li,Li1),
  151.          $db_putbuffbyte(Argno,Buff,Li1,Li2),
  152.          $db_putbuffnum(T,Buff,Li2,Lo),
  153.          Ri = Ro
  154.         ) ;
  155.         (real(T) ->             /* getfloatcon(T,Argno) */
  156.             ($opcode( getfloatcon, GetFltOp ),
  157.                         $db_putbuffop(GetFltOp,Buff,Li,Li1),
  158.              $db_putbuffbyte(Argno,Buff,Li1,Li2),
  159.              $db_putbuffloat(T,Buff,Li2,Lo),
  160.              Ri = Ro
  161.             ) ;
  162.             ((T='$var'(Rt,Un), nonvar(Un), Un=U ) ->
  163.                      /* gettval(Rt,Argno) */
  164.                 ($opcode( gettval, GetTValOp ),
  165.                                  $db_putbuffope(GetTValOp,Buff,Li,Li1),
  166.                    $db_putbuffbyte(Rt,Buff,Li1,Li2),
  167.                    $db_putbuffbyte(Argno,Buff,Li2,Lo),
  168.                    Ri = Ro
  169.                 ) ;
  170.                 $db_genterms([Argno,T],Ri,Ro,Buff,Li,Lo,U)
  171.             )
  172.             )
  173.         )
  174.      ).
  175.  
  176. $db_genterms([],R,R,_,L,L,_).
  177. $db_genterms([R,T|Ts],Ri,Ro,Buff,Li,Lo,U) :-
  178.     $db_genstruc(T,R,Buff,Ri,Rm,Li,Lm2,Substrs,U),
  179.     $db_genterms(Substrs,Rm,Rm2,Buff,Lm2,Lm3,U),
  180.     $db_genterms(Ts,Rm2,Ro,Buff,Lm3,Lo,U).
  181.  
  182. $db_genstruc((A1,A2),R,Buff,Ri,Ro,Li,Lo,[],U) :-
  183.     var(A1),var(A2),A1 \== A2,!,A1 = '$var'(Ri,U),
  184.     Rm1 is Ri+1, A2 = '$var'(Rm1,U), Ro is Rm1+1,
  185.     /* generate a getcomma_tvar_tvar */
  186.     $opcode( getcomma_tvar_tvar, GetCTvTvOp ),
  187.     $db_putbuffop( GetCTvTvOp,Buff,Li,Lm1),
  188.     $db_putbuffbyte(R,Buff,Lm1,Lm2),
  189.     $db_putbuffbyte(Ri,Buff,Lm2,Lm3),
  190.     $db_putbuffbyte(Rm1,Buff,Lm3,Lo).
  191.  
  192. $db_genstruc([A1|A2],R,Buff,Ri,Ro,Li,Lo,[],U) :-
  193.     var(A1),var(A2),not(A1==A2),!,A1 = '$var'(Ri,U),
  194.     Rm1 is Ri+1, A2 = '$var'(Rm1,U), Ro is Rm1+1,
  195.     /* generate a getlist_tvar_tvar */
  196.     $opcode( getlist_tvar_tvar, GetLTvTvOp ),
  197.     $db_putbuffop( GetLTvTvOp,Buff,Li,Lm1),
  198.     $db_putbuffbyte(R,Buff,Lm1,Lm2),
  199.     $db_putbuffbyte(Ri,Buff,Lm2,Lm3),
  200.     $db_putbuffbyte(Rm1,Buff,Lm3,Lo).
  201.  
  202. $db_genstruc(T,R,Buff,Ri,Rm,Li,Lo,Substrs,U) :-
  203.     $db_genget(T,R,Buff,Li,Lm1),$arity(T,Arity),
  204.     $db_dosubs(T,0,Arity,Ri,Rm,Buff,Lm1,Lo,Substrs,[],U).
  205.  
  206.  
  207. $db_genget([_|_],R,Buff,Li,Lo) :- !,
  208.     /* getlist(R) */
  209.     $opcode( getlist, GetLOp ),
  210.     $db_putbuffop( GetLOp,Buff,Li,Li1),
  211.     $db_putbuffbyte(R,Buff,Li1,Lo).
  212.  
  213. $db_genget((_,_),R,Buff,Li,Lo) :- /* not(T=[_|_]) */ !,
  214.     /* getcomma(R) */
  215.     $opcode( getcomma, GetCOp ),
  216.     $db_putbuffop( GetCOp,Buff,Li,Li1),
  217.     $db_putbuffbyte(R,Buff,Li1,Lo).
  218.  
  219. $db_genget(T,R,Buff,Li,Lo) :- /* not(T=(_,_)),not(T=[_|_]) */
  220.     /* functor(T,F,Arity), getstr((F,Arity),R) */
  221.     $opcode( getstr, GetSOp ),
  222.     $db_putbuffop( GetSOp,Buff,Li,Li1),
  223.     $db_putbuffbyte(R,Buff,Li1,Li2),
  224.     $db_putbuffpsc(T,Buff,Li2,Lo).
  225.  
  226. $db_dosubs(T,I,Arity,Ri,Ro,Buff,Li,Lo,Si,So,U) :-
  227.     I < Arity, I1 is I+1, arg(I1,T,Sub),
  228.      $db_geninst(Sub,Ri,Rm,Si,Sm,Buff,Li,Lm,U),
  229.      $db_dosubs(T,I1,Arity,Rm,Ro,Buff,Lm,Lo,Sm,So,U)
  230.     ;
  231.     I >= Arity,        /* just to avoid having to lay down a CP */
  232.      I = Arity,Ri = Ro,Li = Lo,Si = So.
  233.  
  234. $db_geninst(Sub,Ri,Ro,Si,So,Buff,Li,Lo,U) :-
  235.     var(Sub), Si = So,
  236.       Ro is Ri+1, Sub='$var'(Ri,U),     /* unitvar(Ri) */
  237.           $opcode( unitvar, UniTvarOp1 ),
  238.       $db_putbuffop(UniTvarOp1,Buff,Li,Li1),
  239.       $db_putbuffbyte(Ri,Buff,Li1,Lo)
  240.      ;
  241.       nonvar(Sub),
  242.          ($atom(Sub) ->
  243.             ((Sub ?= [] -> 
  244.                  $opcode( uninil, UniNOp ),
  245.                      $db_putbuffope(UniNOp,Buff,Li,Lo) ;   /* uninil */
  246.                  ($opcode( unicon, UniCOp ),
  247.                       $db_putbuffope(UniCOp,Buff,Li,Li1),  /* unicon(Sub) */
  248.               $db_putbuffptr(Sub,Buff,Li1,Lo))
  249.          ),
  250.           Ri = Ro, Si = So) ;
  251.         (integer(Sub) ->               /* uninumcon(Sub) */
  252.               ($opcode( uninumcon, UniNCOp ),
  253.                        $db_putbuffope(UniNCOp,Buff,Li,Li1),
  254.                $db_putbuffnum(Sub,Buff,Li1,Lo),
  255.                Ri = Ro, Si = So) ;
  256.                (real(Sub) ->               /* unifloatcon(Sub) */
  257.                       ($opcode( unifloatcon, UniFltOp ),
  258.                              $db_putbuffope(UniFltOp,Buff,Li,Li1),
  259.                         $db_putbuffloat(Sub,Buff,Li1,Lo),
  260.                      Ri = Ro, Si = So) ;
  261.                      ((Sub='$var'(R,Un),nonvar(Un),Un=U) ->
  262.                             /* unitval(R) */
  263.                     ($opcode( unitval, UniTvalOp ),
  264.                                  $db_putbuffop(UniTvalOp,Buff,Li,Li1),
  265.                       $db_putbuffbyte(R,Buff,Li1,Lo),
  266.                       Ri = Ro, Si = So) ;
  267.                     (Ro is Ri+1,        /* unitvar(Ri) */
  268.                       Si = [Ri,Sub|So],
  269.                                  $opcode( unitvar, UniTvarOp2 ),
  270.                       $db_putbuffop(UniTvarOp2,Buff,Li,Li1),
  271.                       $db_putbuffbyte(Ri,Buff,Li1,Lo))
  272.                        )
  273.             )
  274.         )
  275.          ).
  276.  
  277. $db_genbod(true,0,1,Mvlst,Mvlst,R,R,Buff,Li,Lo,U) :- !,
  278.     $opcode( proceed, ProOp ),
  279.     $db_putbuffope( ProOp /*proceed*/ ,Buff,Li,Lo).
  280.  
  281. $db_genbod(Body,Arity,Argno,Mvlst,Mvlsto,Ri,Ro,Buff,Locin,Locout,U) :-
  282.     $db_genbo1(Body,Arity,Argno,Mvlst,Mvlsto,Ri,Ro,Buff,Locin,Locout,U).
  283.  
  284. $db_genbo1(Body,Arity,Argno,Mvlst,Mvlsto,Ri,Ro,Buff,Locin,Locout,U) :-
  285.     Argno > Arity ->
  286.      Mvlst=Mvlsto,
  287.      $db_genmvs(Mvlst,Ri,Ro,Buff,Locin,Lm1),
  288.      functor(Body,Bodyn,Arity), /* wnl(execute(Bodyn,Arity)), */
  289.          $opcode( execute, ExecOp ),
  290.      $db_putbuffope( ExecOp,Buff,Lm1,Lm2),
  291.      $db_putbuffpsc(Body,Buff,Lm2,Locout)
  292.     ;
  293.      arg(Argno,Body,T),
  294.      $db_genaput(T,Argno,Mvlst,Mvlstm,Ri,Rm,Buff,Locin,Locm,U),
  295.      Argno1 is Argno+1,
  296.      $db_genbo1(Body,Arity,Argno1,Mvlstm,Mvlsto,Rm,Ro,Buff,Locm,Locout,U).
  297.  
  298. $db_genaput(T,Argno,Mvlst,Mvlsto,Ri,Ro,Buff,Locin,Locout,U) :-
  299.     var(T) ->
  300.      Ro is Ri+1,Locout=Locin,Mvlsto=[puttvar(Tempvar),Argno|Mvlst],
  301.      T='$var'(Tempvar,U)
  302.     ;
  303.      (T='$var'(Rt,U) ->
  304.        (var(Rt) -> Mvlsto=[puttvar(Rt),Argno|Mvlst];
  305.                Mvlsto=[movreg(Rt),Argno|Mvlst]),
  306.        Ro=Ri,Locout=Locin
  307.       ;
  308.        (integer(T) ->
  309.          Mvlsto=[putnumcon(T),Argno|Mvlst],Ro=Ri,Locout=Locin
  310.         ;
  311.          (real(T) ->
  312.            (Mvlsto=[putfloatcon(T),Argno|Mvlst],Ro=Ri,Locout=Locin)
  313.           ;
  314.           ($atom(T) ->
  315.         (T ?= [] -> Mvlsto=[putnil,Argno|Mvlst];
  316.              Mvlsto=[putcon(T),Argno|Mvlst]),
  317.         Ro=Ri,Locout=Locin
  318.           ;
  319.         Mvlsto=[movreg(Ri),Argno|Mvlst],Rm is Ri+1,
  320.             $db_putterm(Ri,T,Rm,Ro,Buff,Locin,Locout,U)
  321.          )
  322.        )
  323.      )
  324.     ).
  325.  
  326. $db_putterm(R,T,Ri,Ro,Buff,Li,Lo,U) :-
  327.     $arity(T,Arity),
  328.     $db_putsubstr(T,0,Arity,Ri,Rm,Buff,Li,Lm1,[],Subterms,U),
  329.     $db_genputstr(T,R,Buff,Lm1,Lm2),
  330.     $db_putsubs(Subterms,Rm,Ro,Buff,Lm2,Lo).
  331.  
  332. $db_genputstr([_|_],R,Buff,Li,Lo) :- !,
  333.     /* wnl(putlist(R)), */
  334.     $opcode( putlist, PutLOp ),
  335.     $db_putbuffop(PutLOp,Buff,Li,Li1),
  336.     $db_putbuffbyte(R,Buff,Li1,Lo).
  337.  
  338. $db_genputstr(T,R,Buff,Li,Lo) :- /* not(T=(_,_)),not(T=[_|_]) */
  339.     /* functor(T,F,Arity), wnl(putstr((F,Arity),R)), */
  340.     $opcode( putstr, PutSOp ),
  341.     $db_putbuffop(PutSOp,Buff,Li,Li1),
  342.     $db_putbuffbyte(R,Buff,Li1,Li2),
  343.     $db_putbuffpsc(T,Buff,Li2,Lo).
  344.  
  345. $db_putsubstr(T,I,Arity,Ri,Ro,Buff,Li,Lo,Si,So,U) :-
  346.     I < Arity -> I1 is I+1, arg(I1,T,Sub),
  347.      $db_bldsubs(Sub,Ri,Rm,Si,Sm,Buff,Li,Lm,U),
  348.      $db_putsubstr(T,I1,Arity,Rm,Ro,Buff,Lm,Lo,Sm,So,U)
  349.     ;
  350.      I = Arity,Ri = Ro,Li = Lo,Si = So.
  351.  
  352. $db_bldsubs(Sub,Ri,Ro,Si,So,Buff,Li,Lo,U) :-
  353.     var(Sub) -> So = [bldtvar(Ri)|Si],
  354.       Ro is Ri+1, Li = Lo, Sub='$var'(Ri,U)     /* bldtvar(Ri) */
  355.      ;
  356.       ($atom(Sub) ->
  357.          (Sub ?= [] -> So = [bldnil|Si];    /* bldnil */
  358.             So = [bldcon(Sub)|Si]), /* bldcon(Sub) */
  359.          Ri = Ro, Li = Lo
  360.         ;
  361.          (integer(Sub) ->               /* bldnumcon(Sub) */
  362.         So = [bldnumcon(Sub)|Si], Ri = Ro, Li = Lo
  363.           ;
  364.             (real(Sub) ->               /* bldfloatcon(Sub) */
  365.            (So = [bldfloatcon(Sub)|Si], Ri = Ro, Li = Lo) ;
  366.            ((Sub='$var'(R,Un),nonvar(Un),Un=U) ->
  367.               So = [bldtval(R)|Si],    /* bldtval(R) */
  368.               Ri = Ro,Li = Lo
  369.              ;
  370.               Rm is Ri+1,        /* bldtvar(Ri) */
  371.               So = [bldtval(Ri)|Si], 
  372.               $db_putterm(Ri,Sub,Rm,Ro,Buff,Li,Lo,U)
  373.           ) 
  374.         )
  375.          )
  376.       ).
  377.  
  378. $db_putsubs([],R,R,_,L,L).
  379. $db_putsubs([Bld|Rest],Ri,Ro,Buff,Li,Lo) :-
  380.     $db_putsubs(Rest,Ri,Ro,Buff,Li,Lm),
  381.     $db_bldinst(Bld,Buff,Lm,Lo).
  382.  
  383. :- mode($db_bldinst,4,[c,d,d,d]).
  384.  
  385. $db_bldinst(bldtvar(R),Buff,Li,Lo) :-
  386.     /* wnl(bldtvar(R)), */
  387.     $opcode( bldtvar, BldOp ),
  388.     $db_putbuffop(BldOp,Buff,Li,Li1),
  389.     $db_putbuffbyte(R,Buff,Li1,Lo).
  390. $db_bldinst(bldnil,Buff,Li,Lo) :-
  391.     /* wnl(bldnil), */
  392.     $opcode( bldnil, BldOp ),
  393.     $db_putbuffope(BldOp,Buff,Li,Lo).
  394. $db_bldinst(bldcon(Sub),Buff,Li,Lo) :-
  395.     /* wnl(bldcon(Sub)), */
  396.     $opcode( bldcon, BldOp ),
  397.     $db_putbuffope(BldOp,Buff,Li,Li1),
  398.     $db_putbuffptr(Sub,Buff,Li1,Lo).
  399. $db_bldinst(bldnumcon(Sub),Buff,Li,Lo) :-
  400.     /* wnl(bldnumcon(Sub)), */
  401.     $opcode( bldnumcon, BldOp ),
  402.     $db_putbuffope(BldOp,Buff,Li,Li1),
  403.     $db_putbuffnum(Sub,Buff,Li1,Lo).
  404. $db_bldinst(bldfloatcon(Sub),Buff,Li,Lo) :-
  405.     /* wnl(bldfloatcon(Sub)), */
  406.     $opcode( bldfloatcon, BldOp ),
  407.     $db_putbuffope(BldOp,Buff,Li,Li1),
  408.     $db_putbuffloat(Sub,Buff,Li1,Lo).
  409. $db_bldinst(bldtval(R),Buff,Li,Lo) :-
  410.     /* wnl(bldtval(R)), */
  411.     $opcode( bldtval, BldOp ),
  412.     $db_putbuffop(BldOp,Buff,Li,Li1),
  413.     $db_putbuffbyte(R,Buff,Li1,Lo).
  414.  
  415.  
  416. /* this is a simple routine to generate  a series  of instructions to
  417. load a series of  registers with  constants or  from other registers.
  418. It is  given a  list of  Source,Target pairs.   Target  is always a
  419. register  number.  Source may be a putcon(con), putnumcon(num), putfloatcon(num),
  420. puttvar(reg),  puttvar(Var),  or  movreg(reg).    The  registers  can
  421. overlap in any way.  $db_genmvs tries to generate  a reasonably efficient
  422. series  of  instructions  to  load  the indicated  registers with the
  423. indicated values.  */ 
  424.  
  425. $db_genmvs([],R,R,B,L,L).
  426. $db_genmvs([I,T|Rest],Ri,Ro,Buff,Li,Lo) :- $db_genmvs(I,T,Ri,Ro,Buff,Li,Lo,Rest).
  427.  
  428. :- mode($db_genmvs,8,[c,c,d,d,d,d,d,d]).
  429.  
  430. $db_genmvs(puttvar(R),T,Ri,Ro,Buff,Li,Lo,Rest) :-
  431.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  432.     (nonvar(R) -> 
  433.         /* wnl(movreg(R,T)), */
  434.         $opcode( movreg, MovOp ),
  435.                 $db_putbuffope( MovOp,Buff,Lm,Lm1),
  436.         $db_putbuffbyte(R,Buff,Lm1,Lm2),
  437.         $db_putbuffbyte(T,Buff,Lm2,Lo)
  438.       ;
  439.         R=T, /* wnl(puttvar(R,R)), */
  440.         $opcode( puttvar, PutOp ),
  441.                 $db_putbuffope(PutOp,Buff,Lm,Lm1),
  442.         $db_putbuffbyte(R,Buff,Lm1,Lm2),
  443.         $db_putbuffbyte(R,Buff,Lm2,Lo)
  444.     ).
  445.  
  446. $db_genmvs(putcon(C),T,Ri,Ro,Buff,Li,Lo,Rest) :- !,
  447.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  448.     /* wnl(putcon(T,C)), */
  449.     $opcode( putcon, PutOp ),
  450.     $db_putbuffop(PutOp,Buff,Lm,Lm1),
  451.     $db_putbuffbyte(T,Buff,Lm1,Lm2),
  452.     $db_putbuffptr(C,Buff,Lm2,Lo).
  453.  
  454. $db_genmvs(putnil,T,Ri,Ro,Buff,Li,Lo,Rest) :- !,
  455.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  456.     /* wnl(putnil(T)), */
  457.     $opcode( putnil, PutOp ),
  458.     $db_putbuffop(PutOp,Buff,Lm,Lm1),
  459.     $db_putbuffbyte(T,Buff,Lm1,Lo).
  460.  
  461. $db_genmvs(putnumcon(I),T,Ri,Ro,Buff,Li,Lo,Rest) :- !,
  462.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  463.     /* wnl(putnumcon(T,I)), */
  464.     $opcode( putnumcon, PutOp ),
  465.     $db_putbuffop(PutOp,Buff,Lm,Lm1),
  466.     $db_putbuffbyte(T,Buff,Lm1,Lm2),
  467.     $db_putbuffnum(I,Buff,Lm2,Lo).
  468.  
  469. $db_genmvs(putfloatcon(I),T,Ri,Ro,Buff,Li,Lo,Rest) :- !,
  470.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  471.     /* wnl(putfloatcon(T,I)), */
  472.     $opcode( putfloatcon, PutOp ),
  473.     $db_putbuffop(PutOp,Buff,Lm,Lm1),
  474.     $db_putbuffbyte(T,Buff,Lm1,Lm2),
  475.     $db_putbuffloat(I,Buff,Lm2,Lo).
  476.  
  477. $db_genmvs(movreg(R),R,Ri,Ro,Buff,Li,Lo,Rest) :- !,
  478.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lo).
  479.  
  480. $db_genmvs(movreg(S),T,Ri,Ro,Buff,Li,Lo,Rest) :- not($dbcmpl_frstmem(T,Rest)),!,
  481.     /* wnl(movreg(S,T)), */
  482.     $opcode( movreg, MovOp ),
  483.     $db_putbuffope( MovOp,Buff,Li,Lm1),
  484.     $db_putbuffbyte(S,Buff,Lm1,Lm2),
  485.     $db_putbuffbyte(T,Buff,Lm2,Lm),
  486.     $db_genmvs(Rest,Ri,Ro,Buff,Lm,Lo).
  487.  
  488. $db_genmvs(movreg(S),T,Ri,Ro,Buff,Li,Lo,Rest) :-
  489.     not($dbcmpl_scndmem(S,Rest)), !,
  490.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  491.     /* wnl(movreg(S,T)), */
  492.     $opcode( movreg, MovOp ),
  493.     $db_putbuffope( MovOp,Buff,Lm,Lm1),
  494.     $db_putbuffbyte(S,Buff,Lm1,Lm2),
  495.     $db_putbuffbyte(T,Buff,Lm2,Lo).
  496.  
  497. $db_genmvs(movreg(S),T,Ri,Ro,Buff,Li,Lo,Rest) :- 
  498.     /* wnl(movreg(S,Ri)), */
  499.     $opcode( movreg, MovOp ),
  500.     $db_putbuffope( MovOp,Buff,Li,Lm1),
  501.     $db_putbuffbyte(S,Buff,Lm1,Lm2),
  502.     $db_putbuffbyte(Ri,Buff,Lm2,Lm3),
  503.     Rm is Ri+1,
  504.     $db_genmvs(Rest,Rm,Ro,Buff,Lm3,Lm4),
  505.     /* wnl(movreg(Ri,T)), */
  506.     $db_putbuffope( MovOp,Buff,Lm4,Lm5),
  507.     $db_putbuffbyte(Ri,Buff,Lm5,Lm6),
  508.     $db_putbuffbyte(T,Buff,Lm6,Lo).
  509.  
  510.  
  511. /* wnl(X) :- write(X),nl. */
  512.  
  513.  
  514. $dbcmpl_frstmem(T,[movreg(T),_|_]).
  515. $dbcmpl_frstmem(T,[_|Rest]) :- $dbcmpl_frstmem(T,Rest).
  516.  
  517.  
  518. $dbcmpl_scndmem(S,[_,S|_]).
  519. $dbcmpl_scndmem(S,[_|Rest]) :- $dbcmpl_scndmem(S,Rest).
  520.  
  521. /*  This is a kludge to fix up a problem with the depth-first
  522.     traversal of arguments interacting in a bad way with the
  523.     flattening of terms.  The problem is that when translating
  524.     arguments in the body, the depth first traversal doesn't take
  525.     into account the fact that subterms may move forward due to
  526.     flattening, thereby changing "first" and "subsequent"
  527.     occurrences of variables.  To make things work, though much
  528.     less efficiently than before, I'm just going through an
  529.     explicit flattening stage beforehand.  I don't doubt there
  530.     are more elegant solutions, I'm just a user who wants to
  531.     use assert to do other things. --skd, Sept. 1986        */
  532.  
  533. $db_flatten(Term,NewTerm,Si,So) :-
  534.     $structure(Term) ->
  535.         (functor(Term,F,N),
  536.          functor(NewTerm,F,N),
  537.          $db_flatten1(Term,0,N,NewTerm,Si,So)
  538.         );
  539.         (NewTerm = Term, Si = So).
  540.  
  541. $db_flatten1(Term,N,Arity,NewTerm,Si,So) :-
  542.     (N =:= Arity) ->
  543.         (Si = So) ;
  544.         (ArgNo is N + 1,
  545.          arg(ArgNo,Term,OldArg),
  546.          arg(ArgNo,NewTerm,NewArg),
  547.          (($structure(OldArg), OldArg \= '$var'(_,_)) ->
  548.                    /* nested structure, needs flattening */
  549.              (Sm0 = [NewArg,NewArg0|Si],
  550.              $db_flatten(OldArg,NewArg0,Sm0,Sm1)
  551.             ) ;
  552.             (OldArg = NewArg, Sm1 = Si)
  553.          ),
  554.          N1 is N + 1,
  555.          $db_flatten1(Term,N1,Arity,NewTerm,Sm1,So)
  556.         ).
  557.  
  558. $db_flcode([],R,R,_Buff,Loc,Loc,_).
  559. $db_flcode([Temp,Str|Rest],Ri,Ro,Buff,Li,Lo,U) :-
  560.     Temp = '$var'(R,U),
  561.     ((var(R), R = Ri, Rm0 is Ri+1) ;
  562.      (nonvar(R), Rm0 = Ri)
  563.     ),
  564.     $db_putterm(R,Str,Rm0,Rm1,Buff,Li,Lm,U),
  565.     $db_flcode(Rest,Rm1,Ro,Buff,Lm,Lo,U).
  566.  
  567.